home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / xlispsrc.arc / XLEVAL.C < prev    next >
C/C++ Source or Header  |  1988-02-11  |  19KB  |  838 lines
  1. /* xleval - xlisp evaluator */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. /* macro to check for lambda list keywords */
  9. #define iskey(s) ((s) == lk_optional \
  10.                || (s) == lk_rest \
  11.                || (s) == lk_key \
  12.                || (s) == lk_aux \
  13.                || (s) == lk_allow_other_keys)
  14.  
  15. /* macros to handle tracing */
  16. #define trenter(sym,argc,argv) {if (sym) doenter(sym,argc,argv);}
  17. #define trexit(sym,val) {if (sym) doexit(sym,val);}
  18.  
  19. /* external variables */
  20. extern LVAL xlenv,xlfenv,xldenv,xlvalue,true;
  21. extern LVAL lk_optional,lk_rest,lk_key,lk_aux,lk_allow_other_keys;
  22. extern LVAL s_evalhook,s_applyhook,s_tracelist;
  23. extern LVAL s_lambda,s_macro;
  24. extern LVAL s_unbound;
  25. extern int xlsample;
  26. extern char buf[];
  27.  
  28. /* forward declarations */
  29. FORWARD LVAL xlxeval();
  30. FORWARD LVAL evalhook();
  31. FORWARD LVAL evform();
  32. FORWARD LVAL evfun();
  33.  
  34. /* xleval - evaluate an xlisp expression (checking for *evalhook*) */
  35. LVAL xleval(expr)
  36.   LVAL expr;
  37. {
  38.     /* check for control codes */
  39.     if (--xlsample <= 0) {
  40.     xlsample = SAMPLE;
  41.     oscheck();
  42.     }
  43.  
  44.     /* check for *evalhook* */
  45.     if (getvalue(s_evalhook))
  46.     return (evalhook(expr));
  47.  
  48.     /* check for nil */
  49.     if (null(expr))
  50.     return (NIL);
  51.  
  52.     /* dispatch on the node type */
  53.     switch (ntype(expr)) {
  54.     case CONS:
  55.     return (evform(expr));
  56.     case SYMBOL:
  57.     return (xlgetvalue(expr));
  58.     default:
  59.     return (expr);
  60.     }
  61. }
  62.  
  63. /* xlxeval - evaluate an xlisp expression (bypassing *evalhook*) */
  64. LVAL xlxeval(expr)
  65.   LVAL expr;
  66. {
  67.     /* check for nil */
  68.     if (null(expr))
  69.     return (NIL);
  70.  
  71.     /* dispatch on node type */
  72.     switch (ntype(expr)) {
  73.     case CONS:
  74.     return (evform(expr));
  75.     case SYMBOL:
  76.     return (xlgetvalue(expr));
  77.     default:
  78.     return (expr);
  79.     }
  80. }
  81.  
  82. /* xlapply - apply a function to arguments (already on the stack) */
  83. LVAL xlapply(argc)
  84.   int argc;
  85. {
  86.     LVAL *oldargv,fun,val;
  87.     int oldargc;
  88.     
  89.     /* get the function */
  90.     fun = xlfp[1];
  91.  
  92.     /* get the functional value of symbols */
  93.     if (symbolp(fun)) {
  94.     while ((val = getfunction(fun)) == s_unbound)
  95.         xlfunbound(fun);
  96.     fun = xlfp[1] = val;
  97.     }
  98.  
  99.     /* check for nil */
  100.     if (null(fun))
  101.     xlerror("bad function",fun);
  102.  
  103.     /* dispatch on node type */
  104.     switch (ntype(fun)) {
  105.     case SUBR:
  106.     oldargc = xlargc;
  107.     oldargv = xlargv;
  108.     xlargc = argc;
  109.     xlargv = xlfp + 3;
  110.     val = (*getsubr(fun))();
  111.     xlargc = oldargc;
  112.     xlargv = oldargv;
  113.     break;
  114.     case CONS:
  115.     if (!consp(cdr(fun)))
  116.         xlerror("bad function",fun);
  117.     if (car(fun) == s_lambda)
  118.         fun = xlclose(NIL,
  119.                       s_lambda,
  120.                       car(cdr(fun)),
  121.                       cdr(cdr(fun)),
  122.                       xlenv,xlfenv);
  123.     else
  124.         xlerror("bad function",fun);
  125.     /**** fall through into the next case ****/
  126.     case CLOSURE:
  127.     if (gettype(fun) != s_lambda)
  128.         xlerror("bad function",fun);
  129.     val = evfun(fun,argc,xlfp+3);
  130.     break;
  131.     default:
  132.     xlerror("bad function",fun);
  133.     }
  134.  
  135.     /* remove the call frame */
  136.     xlsp = xlfp;
  137.     xlfp = xlfp - (int)getfixnum(*xlfp);
  138.  
  139.     /* return the function value */
  140.     return (val);
  141. }
  142.  
  143. /* evform - evaluate a form */
  144. LOCAL LVAL evform(form)
  145.   LVAL form;
  146. {
  147.     LVAL fun,args,val,type;
  148.     LVAL tracing=NIL;
  149.     LVAL *argv;
  150.     int argc;
  151.  
  152.     /* protect some pointers */
  153.     xlstkcheck(2);
  154.     xlsave(fun);
  155.     xlsave(args);
  156.  
  157.     /* get the function and the argument list */
  158.     fun = car(form);
  159.     args = cdr(form);
  160.  
  161.     /* get the functional value of symbols */
  162.     if (symbolp(fun)) {
  163.     if (getvalue(s_tracelist) && member(fun,getvalue(s_tracelist)))
  164.         tracing = fun;
  165.     fun = xlgetfunction(fun);
  166.     }
  167.  
  168.     /* check for nil */
  169.     if (null(fun))
  170.     xlerror("bad function",NIL);
  171.  
  172.     /* dispatch on node type */
  173.     switch (ntype(fun)) {
  174.     case SUBR:
  175.     argv = xlargv;
  176.     argc = xlargc;
  177.     xlargc = evpushargs(fun,args);
  178.     xlargv = xlfp + 3;
  179.     trenter(tracing,xlargc,xlargv);
  180.     val = (*getsubr(fun))();
  181.     trexit(tracing,val);
  182.     xlsp = xlfp;
  183.     xlfp = xlfp - (int)getfixnum(*xlfp);
  184.     xlargv = argv;
  185.     xlargc = argc;
  186.     break;
  187.     case FSUBR:
  188.     argv = xlargv;
  189.     argc = xlargc;
  190.     xlargc = pushargs(fun,args);
  191.     xlargv = xlfp + 3;
  192.     val = (*getsubr(fun))();
  193.     xlsp = xlfp;
  194.     xlfp = xlfp - (int)getfixnum(*xlfp);
  195.     xlargv = argv;
  196.     xlargc = argc;
  197.     break;
  198.     case CONS:
  199.     if (!consp(cdr(fun)))
  200.         xlerror("bad function",fun);
  201.     if ((type = car(fun)) == s_lambda)
  202.          fun = xlclose(NIL,
  203.                        s_lambda,
  204.                        car(cdr(fun)),
  205.                        cdr(cdr(fun)),
  206.                        xlenv,xlfenv);
  207.     else
  208.         xlerror("bad function",fun);
  209.     /**** fall through into the next case ****/
  210.     case CLOSURE:
  211.     if (gettype(fun) == s_lambda) {
  212.         argc = evpushargs(fun,args);
  213.         argv = xlfp + 3;
  214.         trenter(tracing,argc,argv);
  215.         val = evfun(fun,argc,argv);
  216.         trexit(tracing,val);
  217.         xlsp = xlfp;
  218.         xlfp = xlfp - (int)getfixnum(*xlfp);
  219.     }
  220.     else {
  221.         macroexpand(fun,args,&fun);
  222.         val = xleval(fun);
  223.     }
  224.     break;
  225.     default:
  226.     xlerror("bad function",fun);
  227.     }
  228.  
  229.     /* restore the stack */
  230.     xlpopn(2);
  231.  
  232.     /* return the result value */
  233.     return (val);
  234. }
  235.  
  236. /* xlexpandmacros - expand macros in a form */
  237. LVAL xlexpandmacros(form)
  238.   LVAL form;
  239. {
  240.     LVAL fun,args;
  241.     
  242.     /* protect some pointers */
  243.     xlstkcheck(3);
  244.     xlprotect(form);
  245.     xlsave(fun);
  246.     xlsave(args);
  247.  
  248.     /* expand until the form isn't a macro call */
  249.     while (consp(form)) {
  250.     fun = car(form);        /* get the macro name */
  251.     args = cdr(form);        /* get the arguments */
  252.     if (!symbolp(fun) || !fboundp(fun))
  253.         break;
  254.     fun = xlgetfunction(fun);    /* get the expansion function */
  255.     if (!macroexpand(fun,args,&form))
  256.         break;
  257.     }
  258.  
  259.     /* restore the stack and return the expansion */
  260.     xlpopn(3);
  261.     return (form);
  262. }
  263.  
  264. /* macroexpand - expand a macro call */
  265. int macroexpand(fun,args,pval)
  266.   LVAL fun,args,*pval;
  267. {
  268.     LVAL *argv;
  269.     int argc;
  270.     
  271.     /* make sure it's really a macro call */
  272.     if (!closurep(fun) || gettype(fun) != s_macro)
  273.     return (FALSE);
  274.     
  275.     /* call the expansion function */
  276.     argc = pushargs(fun,args);
  277.     argv = xlfp + 3;
  278.     *pval = evfun(fun,argc,argv);
  279.     xlsp = xlfp;
  280.     xlfp = xlfp - (int)getfixnum(*xlfp);
  281.     return (TRUE);
  282. }
  283.  
  284. /* evalhook - call the evalhook function */
  285. LOCAL LVAL evalhook(expr)
  286.   LVAL expr;
  287. {
  288.     LVAL *newfp,olddenv,val;
  289.  
  290.     /* create the new call frame */
  291.     newfp = xlsp;
  292.     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  293.     pusharg(getvalue(s_evalhook));
  294.     pusharg(cvfixnum((FIXTYPE)2));
  295.     pusharg(expr);
  296.     pusharg(cons(xlenv,xlfenv));
  297.     xlfp = newfp;
  298.  
  299.     /* rebind the hook functions to nil */
  300.     olddenv = xldenv;
  301.     xldbind(s_evalhook,NIL);
  302.     xldbind(s_applyhook,NIL);
  303.  
  304.     /* call the hook function */
  305.     val = xlapply(2);
  306.  
  307.     /* unbind the symbols */
  308.     xlunbind(olddenv);
  309.  
  310.     /* return the value */
  311.     return (val);
  312. }
  313.  
  314. /* evpushargs - evaluate and push a list of arguments */
  315. LOCAL int evpushargs(fun,args)
  316.   LVAL fun,args;
  317. {
  318.     LVAL *newfp;
  319.     int argc;
  320.     
  321.     /* protect the argument list */
  322.     xlprot1(args);
  323.  
  324.     /* build a new argument stack frame */
  325.     newfp = xlsp;
  326.     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  327.     pusharg(fun);
  328.     pusharg(NIL); /* will be argc */
  329.  
  330.     /* evaluate and push each argument */
  331.     for (argc = 0; consp(args); args = cdr(args), ++argc)
  332.     pusharg(xleval(car(args)));
  333.  
  334.     /* establish the new stack frame */
  335.     newfp[2] = cvfixnum((FIXTYPE)argc);
  336.     xlfp = newfp;
  337.     
  338.     /* restore the stack */
  339.     xlpop();
  340.  
  341.     /* return the number of arguments */
  342.     return (argc);
  343. }
  344.  
  345. /* pushargs - push a list of arguments */
  346. int pushargs(fun,args)
  347.   LVAL fun,args;
  348. {
  349.     LVAL *newfp;
  350.     int argc;
  351.     
  352.     /* build a new argument stack frame */
  353.     newfp = xlsp;
  354.     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  355.     pusharg(fun);
  356.     pusharg(NIL)